﻿<%
'自动保存功能
dim sContentPath,rContentPath,nAllowSize,sAllowExt

'================================================
'作  用：'载入远程上传功能
'参  数：略
'================================================

Function DoRemoteUpload(Upword,UpMax,UpFileType,UpDir,UpChannel)
    '为了节省空间，限制图片大小，如果超过nAllowSize，则不保存到本地
    nAllowSize = UpMax
    '图片类型限制，如果不是以下类型图片，则不保存到本地
    sAllowExt = UpFileType
    '保存目录
    sContentPath=InstallDir & UploadSetting(1) &"/"& UpDir &"/"
	'日期目录
	If UpChannel = 1 Then sContentPath = CreatePath(sContentPath) '按年月分类目录
	rContentPath=Replace(sContentPath,InstallDir & UploadSetting(1) &"/"& UpDir &"/","{$download_dir}/"& UpDir &"/")
	'执行保存
	DoRemoteUpload = ReplaceRemoteUrl(Upword, sAllowExt)
End Function

'================================================
'作  用：替换字符串中的远程文件为本地文件并保存远程文件
'参  数：
'	sHTML: 要替换的字符串
'	sExt : 执行替换的扩展名
'================================================
Function ReplaceRemoteUrl(sHTML, sExt)
	Dim s_Content
	s_Content = sHTML
	If IsObjInstalled("Microsoft.XMLHTTP") = False Then
		ReplaceRemoteUrl = s_Content
		Exit Function
	End If

	Dim RemoteFile, RemoteFileurl, SaveFileName, SaveFileType
	regEx.Pattern ="((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}(([A-Za-z0-9_-])+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(" & sExt & ")))"
	Set RemoteFile = regEx.Execute(s_Content)
	Dim a_RemoteUrl(), n, i, bRepeat
	n = 0
	' 转入无重复数据
	For Each RemoteFileurl in RemoteFile
		If n = 0 Then
			n = n + 1
			Redim a_RemoteUrl(n)
			a_RemoteUrl(n) = RemoteFileurl
		Else
			bRepeat = False
			For i = 1 To UBound(a_RemoteUrl)
				If UCase(RemoteFileurl) = UCase(a_RemoteUrl(i)) Then
					bRepeat = True
					Exit For
				End If
		Next
			If bRepeat = False Then
				n = n + 1
				Redim Preserve a_RemoteUrl(n)
				a_RemoteUrl(n) = RemoteFileurl
			End If
		End If		
	Next
	' 开始替换操作
	For i = 1 To n
		SaveFileType = Mid(a_RemoteUrl(i), InstrRev(a_RemoteUrl(i), ".") + 1)
		SaveFileName = GetRndFileName(SaveFileType)
		If SaveRemoteFile(SaveFileName, a_RemoteUrl(i)) = True Then
			s_Content = Replace(s_Content, a_RemoteUrl(i), sContentPath & SaveFileName, 1, -1, 1)
		End If
	Next

	ReplaceRemoteUrl = s_Content
End Function

'================================================
'作  用：保存远程的文件到本地
'参  数：s_LocalFileName ------ 本地文件名
'	     s_RemoteFileUrl ------ 远程文件URL
'返回值：True  ----成功
'        False ----失败
'================================================
Function SaveRemoteFile(s_LocalFileName, s_RemoteFileUrl)
	Dim Ads, Retrieval, GetRemoteData
	Dim bError
	bError = False
	SaveRemoteFile = False
	On Error Resume Next
	Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
	With Retrieval
		.Open "Get", s_RemoteFileUrl, False, "", ""
		.Send
		GetRemoteData = .ResponseBody
	End With
	Set Retrieval = Nothing
	If LenB(GetRemoteData) > nAllowSize*1024 Then
		bError = True
	Else
		Set Ads = Server.CreateObject("Ado"&"db.St"&"ream")
		With Ads
			.Type = 1
			.Open
			.Write GetRemoteData
			.SaveToFile Server.MapPath(sContentPath&s_LocalFileName), 2
			.Cancel()
			.Close()
		End With
		Set Ads=nothing
	End If

	If Err.Number = 0 And bError = False Then
		SaveRemoteFile = True
	Else
		Err.Clear
	End If
End Function

'================================================
'作  用：检查组件是否已经安装
'参  数：strClassString ----组件名
'返回值：True  ----已经安装
'       False ----没有安装
'================================================
Function IsObjInstalled(strClassString)
	On Error Resume Next
	IsObjInstalled = False
	Err = 0
	Dim xTestObj
	Set xTestObj = Server.CreateObject(strClassString)
	If 0 = Err Then IsObjInstalled = True
	Set xTestObj = Nothing
	Err = 0
End Function

' 取随机文件名
Function GetRndFileName(sExt)
	Dim sRnd
	Randomize
	sRnd = Int(900 * Rnd) + 100
	GetRndFileName = year(now) & month(now) & day(now) & hour(now) & minute(now) & second(now) & sRnd & "." & sExt
End Function
'按月份自动明名上传文件夹,需要ＦＳＯ组件支持。
Private Function CreatePath(PathValue)
	Dim objFSO,uploadpath,strTmpPath,a,i
	uploadpath = PathValue & ReplaceTime(Now(), UploadSetting(2))	'以年月创建上传文件夹
	a = Split(uploadpath, "/")
	For i = 0 To (Ubound(a) - 1)
		If Right(PathValue,1)<>"/" Then PathValue = PathValue & "/"
		strTmpPath = strTmpPath & a(i) & "/"
		On Error Resume Next
		Set objFSO = Server.CreateObject(Fso_Sys)
			If objFSO.FolderExists(Server.MapPath(PathValue))=False Then
				objFSO.CreateFolder Server.MapPath(PathValue)
			End If
			If objFSO.FolderExists(Server.MapPath(strTmpPath))=False Then
				objFSO.CreateFolder Server.MapPath(strTmpPath)
			End If
		Set objFSO = Nothing
	Next
	CreatePath = uploadpath
End Function

Function ReplaceTime(s_Time, s_Patt)
	If IsDate(s_Time) = False Then
		ReplaceTime = ""
		Exit Function
	End If
	Dim ret
	ret = s_Patt
	Dim y1, y2, m1, m2, d1, d2, h1, h2, i1, i2, s1, s2
	y2 = CStr(Year(s_Time))
	y1 = Right(y2, 2)
	m1 = CStr(Month(s_Time))
	m2 = Right("0" & m1, 2)
	d1 = CStr(Day(s_Time))
	d2 = Right("0" & d1, 2)
	h1 = CStr(Hour(s_Time))
	h2 = Right("0" & h1, 2)
	i1 = CStr(Minute(s_Time))
	i2 = Right("0" & i1, 2)
	s1 = CStr(Second(s_Time))
	s2 = Right("0" & s1, 2)
	ret = Replace(ret, "{yyyy}", y2, 1, -1, 1)
	ret = Replace(ret, "{yy}", y1, 1, -1, 1)
	ret = Replace(ret, "{mm}", m2, 1, -1, 1)
	ret = Replace(ret, "{m}", m1, 1, -1, 1)
	ret = Replace(ret, "{dd}", d2, 1, -1, 1)
	ret = Replace(ret, "{d}", d1, 1, -1, 1)
	ret = Replace(ret, "{hh}", h2, 1, -1, 1)
	ret = Replace(ret, "{h}", h1, 1, -1, 1)
	ret = Replace(ret, "{ii}", i2, 1, -1, 1)
	ret = Replace(ret, "{i}", i1, 1, -1, 1)
	ret = Replace(ret, "{ss}", s2, 1, -1, 1)
	ret = Replace(ret, "{s}", s1, 1, -1, 1)
	ReplaceTime = ret
End Function

Function GetExt(Getfilename)
dim fname
    fname=split(Getfilename,".")
	GetExt=lcase(fname(1))
End Function
%>